MacTech 1 to 12

home *** CD-ROM | disk | FTP | other *** search

/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 04 - 1988 / 04.10 Oct 88 / TransferSources / drvr.pas < prev next >

Wrap

Pascal/Delphi Source File | 1988-05-22 | 19.2 KB | 751 lines | [TEXT/MPS ]

(******************************************************************* drvr.pas -------- (c) 1987, 1988 Attic Software Pascal routines for DRVR segment of Transfer *******************************************************************) unit drvr; (******************************************************************) interface (******************************************************************) uses macintf, hfs, types; (******************************************************************) implementation (******************************************************************) procedure initglobals(globals : wpointer); external; function setdir(dirid : long; globals : wpointer) : OSErr; external; (******************************************************************* procedure drawscreen -------------------- This routine draws the “About” message in its rectangle. *******************************************************************) procedure drawscreen(theWindow : WindowPtr; theitem : integer); var theType : integer; theHandle : Handle; thebox : Rect; begin SetPort(theWindow); GetFNum('monaco', theType); TextFont(theType); TextSize(9); GetDItem(theWindow, theitem, theType, theHandle, thebox); theHandle := GetResource('INFO', GetWRefCon(theWindow)); HLock(theHandle); TextBox(theHandle^, GetHandleSize(theHandle), thebox, 0); HUnlock(theHandle); end; (******************************************************************* procedure transalert -------------------- I want all the alerts to identify their source, so I made them dialogs, in titled windows, and wrote this routine to imitate “Alert”. This is not the best way to do it; for one thing, a titled window should be dragable. Modal dialogs, therefore, should not have titles. I should have simply added a distinctive icon to the item lists. Since this is the first use of the “resfactor” field of the global record, it's as good a place as any to explain it. This DA is given a formal resource id of 16, and all its owned resources are numbered accordingly. The Font/DA Mover will change all these numbers when it installs the DA. “resfactor”, which is computed in the “open” routine, below, is the correction factor that converts the hard-coded resource ids to the actual ids in use. Note that “resfactor” doesn't convert the formal ids; it actually converts the constants defined in the “types.pas” unit, which are nice positive numbers, equal to the resource ids plus 16872. There's a little bit of code to install the previous procedure if this is the “About” dialog. *******************************************************************) procedure transalert(dialognum : integer; globals : wpointer); var savedport : GrafPtr; theDialog : DialogPtr; therecord : DialogRecord; theType : integer; theHandle : Handle; thebox : Rect; choice : integer; begin with globals^ do begin GetPort(savedport); theDialog := GetNewDialog(dialognum + resfactor, @therecord, pointer(-1)); SetPort(theDialog); if dialognum = aboutdialog then begin GetDItem(theDialog, 2, theType, theHandle, thebox); SetDItem(theDialog, 2, theType, Handle(@drawscreen), thebox); SetWRefCon(theDialog, dialognum + resfactor); end; InitCursor; ShowWindow(theDialog); repeat ModalDialog(nil, choice); until choice = ok; CloseDialog(theDialog); SetPort(savedport); end; end; (******************************************************************* procedure errordisplay ---------------------- This routine displays error messages. The texts of the messages are in a string list. *******************************************************************) procedure errordisplay(appnum, sysnum, resnum : long; globals : wpointer); var string1 : Str255; string3 : Str255; string4 : Str255; begin InitCursor; with globals^ do begin GetIndString(string1, resfactor + stringnum, resnum); if string1 = '' then string1 := 'An error has occurred!'; NumToString(appnum, string3); NumToString(sysnum, string4); ParamText(string1, '', string3, string4); SysBeep(10); transalert(errordialog, globals); end; end; (******************************************************************* procedure getapps ----------------- Here it is - the only recursive routine I have ever been forced to use! (Recursion is overrated; it is, in my opinion, better to avoid recursion, if you can do it in a natural fashion. Loops are easier to read, and generally more efficient.) This routine is passed a directory id, the count of objects (files and folders) in that directory, and the volume reference number. It indexes through the directory with “PBGetCatInfo”. If the object is another directory, it calls itself with that directory's id and count. If the object is a file, and if the file is an application, it records its name and the directory id in the application array. *******************************************************************) procedure getapps(thedir : long; thecount : integer; thevol : integer; theHandle : arrayhandle; globals : wpointer); label 100; var index : integer; anerror : integer; theDialog : DialogPtr; jndex : integer; thelength : integer; thedesk : deskhandle; begin with globals^ do begin for index := 1 to thecount do with infoblock do begin thename := ''; ioCompletion := nil; ioNamePtr := @thename; ioVRefNum := thevol; ioFDirIndex := index; ioDrDirID := thedir; anerror := PBGetCatInfo(@infoblock, false); if anerror <> noErr then begin errordisplay(101, anerror, 2, globals); goto 100; end; if BitAnd(ioFlAttrib, $10) = $10 then getapps(ioDrDirID, ioDrNmFls, thevol, theHandle, globals) else if ioFlFndrInfo.fdType = 'APPL' then begin jndex := theHandle^^.count + 1; theHandle^^.count := jndex; SetHandleSize(Handle(theHandle), 5 * (jndex + 1)); HLock(Handle(theHandle)); with theHandle^^ do while (IUCompString(thename, data[jndex - 1]^^.name) < 0) and (jndex > 1) do begin data[jndex] := data[jndex - 1]; jndex := jndex - 1; end; thelength := 10 + length(thename); thelength := 2 * (thelength div 2); theHandle^^.data[jndex] := deskhandle(NewHandle(thelength)); with theHandle^^.data[jndex]^^ do begin dirid := thedir; name := thename; end; HUnlock(Handle(theHandle)); end; 100: end; end; end; (******************************************************************* procedure walktree ------------------ This routine catalogs all the applications on a given disk. It first puts up a dialog, telling the user what's going on. It next calls “PBGetCatInfo” for the root directory (directory id = 2), to get the number of objects in the root. Then it calls “getapps” to walk the HFS tree recursively. The collected data is written to the current resource file (“Transfer Data”, in the System folder), and the dialog is dismissed. *******************************************************************) procedure walktree(thevol : integer; theHandle : arrayhandle; globals : wpointer); var savedport : GrafPtr; theDialog : DialogPtr; therecord : DialogRecord; index : integer; anerror : integer; begin with globals^ do begin GetPort(savedport); theDialog := GetNewDialog(resfactor + builddialog, @therecord, pointer(-1)); SetPort(theDialog); ShowWindow(theDialog); DrawDialog(theDialog); with infoblock do begin ioCompletion := nil; ioNamePtr := nil; ioVRefNum := thevol; ioFDirIndex := 0; ioDrDirID := 2; end; anerror := PBGetCatInfo(@infoblock, false); if anerror <> noErr then errordisplay(102, anerror, 2, globals) else getapps(2, infoblock.ioDrNmFls, thevol, theHandle, globals); end; HLock(Handle(theHandle)); with theHandle^^ do for index := 1 to count do begin AddResource(Handle(data[index]), '.Trn', datastart + index, data[index]^^.name); SetHandleSize(Handle(data[index]), 4); end; HUnlock(Handle(theHandle)); CloseDialog(theDialog); SetPort(savedport); end; (******************************************************************* procedure buildmenu ------------------- This routine assembles the necessary data, and builds the Transfer menu. It finds the volume reference number of the disk with the System folder, sets the directory to the System folder, and opens or creates the “Transfer Data” file in that directory. If this file lacks a header resource (whether because it was just created, or because it has been corrupted), then it must be rebuilt, with “walktree”. Then the menu is built. The menu resource is loaded, and the fourth item set to the name of the current Finder. The remainder of the menu is copied from the resource file. *******************************************************************) procedure buildmenu(globals : wpointer); label 100; var thepointer : shortpointer; thevolume : integer; theres : integer; theHandle : arrayhandle; index : integer; jndex : integer; thedesk : Handle; theID : integer; theType : ResType; anerror : integer; begin with globals^ do begin thepointer := shortpointer(sysmap); anerror := GetVRefNum(thepointer^, thevolume); if anerror <> noErr then begin errordisplay(103, anerror, 3, globals); goto 100; end; anerror := setdir(sysdir, globals); if anerror <> noErr then begin errordisplay(104, anerror, 3, globals); goto 100; end; thename := 'Transfer Data'; theres := OpenResFile(thename); if ResError = fnfErr then begin CreateResFile(thename); theres := OpenResFile(thename); end; if ResError <> noErr then begin errordisplay(105, ResError, 3, globals); goto 100; end; theHandle := arrayhandle(Get1Resource('.Trn', datastart)); if theHandle = nil then begin theHandle := arrayhandle(NewHandle(6)); theHandle^^.count := 0; theHandle^^.data[0] := deskhandle(NewHandle(16)); AddResource(Handle(theHandle), '.Trn', datastart, ''); walktree(thevolume, theHandle, globals); SetHandleSize(Handle(theHandle), 2); end; theMenu := GetMenu(resfactor + menunum); BlockMove(Ptr(findername), Ptr(@thename), 16); SetItem(theMenu, 4, thename); jndex := 1; for index := 1 to theHandle^^.count do begin thedesk := Get1Resource('.Trn', datastart + index); if thedesk <> nil then begin AppendMenu(theMenu, '.Trn'); GetResInfo(thedesk, theID, theType, thename); SetItem(theMenu, jndex + 4, thename); jndex := jndex + 1; end; end; InsertMenu(theMenu, 0); DrawMenuBar; CloseResFile(theres); 100: end; end; (******************************************************************* function systemvol ------------------ This routine is more or less straight out of Tech Note 77, pages 3 and 4. It returns a working directory reference number for the System folder, suitable for use in file system calls. Step one is to find the volume reference number of the volume that holds the System folder. “sysmap” is the file reference number of the System file (an open file), so “GetVRefNum” will find the volume refence number of the System file and, of course, the System folder. Step two is to get the directory id, with a call to “PBHGetVInfo”. The directory id is returned in the “ioVFndrInfo[1]” field of the HParamBlockRec. Finally, “PBOpenWD” will return the System folder's working directory reference number, which can be used as a volume reference number in file system calls. *******************************************************************) function systemvol(globals : wpointer) : integer; var thepointer : shortpointer; thevolume : integer; anerror : integer; begin with globals^ do begin thepointer := shortpointer(sysmap); anerror := GetVRefNum(thepointer^, thevolume); with hblock do begin ioNamePtr := nil; ioVRefNum := thevolume; ioVolIndex := 0; end; anerror := PBHGetVInfo(@hblock, false); with wdblock do begin ioWDDirID := hblock.ioVFndrInfo[1]; ioNamePtr := nil; ioVRefNum := thevolume; ioWDProcID := erik; end; anerror := PBOpenWD(@wdblock, false); systemvol := wdblock.ioVRefNum; end; end; (******************************************************************* procedure rebuildmenu --------------------- If the “Rebuild menu” item is chosen from the menu, or an application is chosen which can't be found, Transfer will rebuild the menu from scratch. It does this by deleting the “Transfer Data” file, and calling “buildmenu”. *******************************************************************) procedure rebuildmenu(globals : wpointer); var anerror : integer; begin with globals^ do begin DeleteMenu(resfactor + menunum); ReleaseResource(Handle(theMenu)); anerror := FSDelete('Transfer Data', systemvol(globals)); buildmenu(globals); end; end; (******************************************************************* procedure dofinder ------------------ If the “Finder” item is chosen from the menu, then no transfer is desired, so restore the “iaznotify” hook to the value it held when Transfer was launched. (This isn't quite right, since something besides Transfer may have changed it since then. but I don't see any way to correct for that...) If the option key is down, do nothing else. Otherwise, do an immediate transfer by calling “ExitToShell”. *******************************************************************) procedure dofinder(globals : wpointer); var thepointer : longpointer; begin with globals^ do begin thepointer := longpointer(iaznotify); thepointer^ := iazaddr; if GetNextEvent(0, theEvent) then ; if BitAnd(theEvent.modifiers, optionKey) = 0 then ExitToShell; end; end; (******************************************************************* procedure clickmenu ------------------- The first few menu choices are handled by routines above. If an application is chosen, we need to get (1) the application's name, and (2) its directory. The name is easy; it's on the menu. To get the directory, we have to go back to the “Transfer Data” file. Once we have the application's directory, the next thing to do is to make sure it's there. Transferring to a non-existent application will cause a system bomb. If everything is ok, then if the option key is down, prepare to do a delayed transfer; otherwise, do an immediate transfer by calling “ExitToShell”. *******************************************************************) procedure clickmenu(itemchoice : integer; globals : wpointer); label 100; var theres : integer; thedesk : deskhandle; theinfo : FInfo; thepointer : longpointer; anerror : integer; begin with globals^ do begin case itemchoice of aboutitem : transalert(aboutdialog, globals); builditem : rebuildmenu(globals); finderitem : dofinder(globals); otherwise thepointer := longpointer(iaznotify); thepointer^ := launchaddr; anerror := setdir(sysdir, globals); if anerror <> noErr then begin errordisplay(106, anerror, 3, globals); goto 100; end; theres := OpenResFile('Transfer Data'); if ResError <> noErr then begin rebuildmenu(globals); goto 100; end; GetItem(theMenu, itemchoice, thename); thedesk := deskhandle(Get1NamedResource('.Trn', thename)); DetachResource(Handle(thedesk)); CloseResFile(theres); if thedesk = nil then begin rebuildmenu(globals); goto 100; end; anerror := setdir(thedesk^^.dirid, globals); if anerror <> noErr then begin rebuildmenu(globals); goto 100; end; anerror := GetFInfo(thename, 0, theinfo); if anerror <> noErr then begin rebuildmenu(globals); goto 100; end; launchpath := thedesk^^.dirid; if GetNextEvent(0, theEvent) then ; if BitAnd(theEvent.modifiers, optionKey) = 0 then ExitToShell else begin ParamText(thename, '', '', ''); transalert(delaydialog, globals); end; end; 100: HiliteMenu(0); end; end; (******************************************************************* procedure open -------------- This is the canonical DA open routine. If the DA has already been opened, device.dCtlMenu will be nonzero; do nothing. Otherwise, Allocate the globals, and fill in a few fields. Of particular interest is the calculation of “resfactor” by the magic formula $BFE0 - 32 * dCtlRefNum - 1000. This, assuming I have given the DA the formal resource id of 16, allows be to refer to owned resources by ids from 1000 to 1031, adding resfactor to convert to the actual values. Next, load and detach the PACK segment. And lock it; it's created locked but why take chances? Finally, call “initglobals” to fill in the rest of the fields, and “buildmenu” to set up the menu. *******************************************************************) procedure open(var device : DCtlEntry; var block : ParamBlockRec); var globals : wpointer; packhandle : Handle; begin if device.dCtlMenu = 0 then begin globals := wpointer(NewPtr(sizeof(wrecord))); if globals <> nil then with globals^ do begin with device do begin resfactor := $BFE0 - 32 * dCtlRefNum - 1000; dCtlMenu := resfactor + menunum; dctlwindow := nil; dCtlStorage := Handle(globals); end; packhandle := GetResource('PACK', resfactor + packnum); DetachResource(packhandle); HLock(packhandle); packaddr := packhandle^; initglobals(globals); buildmenu(globals); end; end; end; (******************************************************************* procedure ctl ------------- The canonical Control routine. The only events we're interested in are menu clicks; if we get one, call “clickmenu”. *******************************************************************) procedure ctl(var device : DCtlEntry; var block : ParamBlockRec); var globals : wpointer; begin if (device.dCtlMenu <> 0) and (block.csCode = accMenu) then begin globals := wpointer(device.dCtlStorage); clickmenu(block.csParam[1], globals); end; end; (******************************************************************) end. (******************************************************************)